home *** CD-ROM | disk | FTP | other *** search
/ Amiga Format CD 41 / Amiga Format CD41 (1999-06)(Future Publishing)(GB)[!][issue 1999-07].iso / -seriously_amiga- / programming / other / scm / slib / nclients.scm < prev    next >
Text File  |  1999-04-19  |  13KB  |  384 lines
  1. ;;; "nclients.scm" Interface to net-client programs.
  2. ; Copyright 1997, 1998 Aubrey Jaffer
  3. ;
  4. ;Permission to copy this software, to redistribute it, and to use it
  5. ;for any purpose is granted, subject to the following restrictions and
  6. ;understandings.
  7. ;
  8. ;1.  Any copy made of this software must include this copyright notice
  9. ;in full.
  10. ;
  11. ;2.  I have made no warrantee or representation that the operation of
  12. ;this software will be error-free, and I am under no obligation to
  13. ;provide any services, by way of maintenance, update, or otherwise.
  14. ;
  15. ;3.  In conjunction with products arising from the use of this
  16. ;material, there shall be no use of my name in any advertising,
  17. ;promotional, or sales literature without prior written consent in
  18. ;each case.
  19.  
  20. (require 'string-search)
  21. (require 'line-i/o)
  22. (require 'system)
  23. (require 'printf)
  24. (require 'scanf)
  25.  
  26. ;;@args proc
  27. ;;@args proc k
  28. ;;Calls @1 with @var{k} arguments, strings returned by successive
  29. ;;calls to @code{tmpnam}.  If @1 returns, then any files named by the
  30. ;;arguments to @1 are deleted automatically and the value(s) yielded
  31. ;;by the @1 is(are) returned.  @var{k} may be ommited, in which case
  32. ;;it defaults to @code{1}.
  33. (define (call-with-tmpnam proc . k)
  34.   (do ((cnt (if (null? k) 0 (+ -1 (car k))) (+ -1 cnt))
  35.        (paths '() (cons (tmpnam) paths)))
  36.       ((negative? cnt)
  37.        (let ((ans (apply proc paths)))
  38.      (for-each (lambda (path) (if (file-exists? path) (delete-file path)))
  39.            paths)
  40.      ans))))
  41.  
  42. ;;@args
  43. ;;@0 returns a string of the form @samp{username@r{@@}hostname}.  If
  44. ;;this e-mail address cannot be obtained, #f is returned.
  45. (define user-email-address
  46.   (let ((user (or (getenv "USER") (getenv "USERNAME")))
  47.     (hostname (getenv "HOSTNAME")))    ;with domain
  48.     (lambda ()
  49.       (if (not (and user hostname))
  50.       (call-with-tmpnam
  51.        (lambda (tmp)
  52.          (define command->string
  53.            (lambda (command)
  54.          (and (zero? (system (string-append command " >" tmp)))
  55.               (file-exists? tmp)
  56.               (let ((res #f))
  57.             (call-with-input-file tmp
  58.               (lambda (port)
  59.                 (and (eqv? 1 (fscanf port "%s" res)) res)))))))
  60.          (case (software-type)
  61.            ;;((AMIGA)                )
  62.            ;;((MACOS THINKC)            )
  63.            ((MS-DOS WINDOWS OS/2 ATARIST)
  64.         (let ((compname (getenv "COMPUTERNAME")) ;without domain
  65.               (workgroup #f)
  66.               (netdir (or (getenv "windir")
  67.                   (getenv "winbootdir")
  68.                   (and (getenv "SYSTEMROOT")
  69.                        (string-append (getenv "SYSTEMROOT")
  70.                               "\\system32"))
  71.                   "C:\\windows")))
  72.           (define (net . cmd)
  73.             (zero? (system (apply string-append
  74.                       (or netdir "")
  75.                       (if netdir "\\" "")
  76.                       "NET " cmd))))
  77.           (and (not (and user hostname))
  78.                (zero? (system (string-append
  79.                        (or netdir "")
  80.                        (if netdir "\\" "")
  81.                        "IPCONFIG /ALL > " tmp " ")))
  82.                (file-exists? tmp)
  83.                ;;(print tmp '=) (display-file tmp)
  84.                (call-with-input-file tmp
  85.              (lambda (port)
  86.                (find-string-from-port? "Host Name" port)
  87.                (fscanf port " %*[. ]: %s" hostname)
  88.                (delete-file tmp))))
  89.           (and (not (and user hostname))
  90.                (net "START /LIST >" tmp)
  91.                (file-exists? tmp)
  92.                (not (eof-object? (call-with-input-file tmp read-char)))
  93.                (cond
  94.             ((call-with-input-file tmp
  95.                (lambda (port)
  96.                  (find-string-from-port? "o network servic" port)))
  97.              (and (net "CONFIG /YES >" tmp)
  98.                   (net "STOP /YES")))
  99.             (else (net "CONFIG /YES >" tmp)))
  100.                (call-with-input-file tmp
  101.              (lambda (port)
  102.                (do ((line (read-line port) (read-line port)))
  103.                    ((eof-object? line))
  104.                  (sscanf line " Workstation root directory %s"
  105.                      netdir)
  106.                  (sscanf line " Computer name \\\\%s" compname)
  107.                  (sscanf line " Workstation Domain %s" workgroup)
  108.                  (sscanf line " Workgroup %s" workgroup)
  109.                  (sscanf line " User name %s" user)))))
  110.           (and netdir (not (and user hostname))
  111.                (set! netdir (string-append netdir "\\system.ini"))
  112.                (file-exists? netdir)
  113.                (call-with-input-file netdir
  114.              (lambda (port)
  115.                (and (find-string-from-port? "[DNS]" port)
  116.                 (read-line port) ;past newline
  117.                 (do ((line (read-line port) (read-line port)))
  118.                     ((not (and (string? line)
  119.                            (string-index line #\=))))
  120.                   (sscanf line "HostName=%s" compname)
  121.                   (sscanf line "DomainName=%s" workgroup)))))
  122.                (not user)
  123.                (call-with-input-file netdir
  124.              (lambda (port)
  125.                (and (find-string-from-port? "[Network]" port)
  126.                 (read-line port) ;past newline
  127.                 (do ((line (read-line port) (read-line port)))
  128.                     ((not (and (string? line)
  129.                            (string-index line #\=))))
  130.                   (sscanf line "UserName=%s" user))))))
  131.           (if (and compname (not hostname))
  132.               (set! hostname
  133.                 (string-append
  134.                  compname "." (or workgroup "localnet"))))))
  135.            ;;((NOSVE)                )
  136.            ;;((VMS)                    )
  137.            ((UNIX COHERENT)
  138.         (if (not user)
  139.             (set! user (command->string "whoami")))
  140.         (if (not hostname)
  141.             (set! hostname (command->string "hostname")))))
  142.          (if (not user) (set! user "John_Doe"))
  143.          (if (not hostname) (set! hostname "localhost")))))
  144.       (string-append user "@" hostname))))
  145.  
  146. ;;@args
  147. ;;@0 returns a string containing the absolute file name representing
  148. ;;the current working directory.  If this string cannot be obtained,
  149. ;;#f is returned.
  150. ;;
  151. ;;If @0 cannot be supported by the platform, the value of @0 is
  152. ;;#f.
  153. (define current-directory
  154.   (case (software-type)
  155.     ;;((AMIGA)                )
  156.     ;;((MACOS THINKC)            )
  157.     ((MS-DOS WINDOWS ATARIST OS/2)
  158.      (lambda ()
  159.        (call-with-tmpnam
  160.     (lambda (tmp)
  161.       (and (zero? (system (string-append "cd >" tmp)))
  162.            (file-exists? tmp)
  163.            (call-with-input-file tmp
  164.          (lambda (port)
  165.            (let ((lst (scanf-read-list "%[^:]%[:] %s" port)))
  166.              (and (pair? lst)
  167.               (eqv? 3 (length lst))
  168.               (apply string-append lst))))))))))
  169.     ;;((NOSVE)                )
  170.     ((UNIX COHERENT)
  171.      (lambda ()
  172.        (call-with-tmpnam
  173.     (lambda (tmp)
  174.       (and (zero? (system (string-append "pwd >" tmp)))
  175.            (file-exists? tmp)
  176.            (let ((path (call-with-input-file tmp read-line)))
  177.          (and (string? path) path)))))))
  178.     ;;((VMS)                )
  179.     (else #f)))
  180.  
  181. ;;@body
  182. ;;Creates a sub-directory @1 of the current-directory.  If successful,
  183. ;;@0 returns #t; otherwise #f.
  184. (define (make-directory name)
  185.   (zero? (system (string-append "mkdir " name))))
  186.  
  187. ;;@body
  188. ;;Returns #t if changing directory to @1 makes the current working
  189. ;;directory the same as it is before changing directory; otherwise
  190. ;;returns #f.
  191. (define (null-directory? file-name)
  192.   (member file-name '("" "." "./" ".\\")))
  193.  
  194. ;;@body
  195. ;;Returns #t if @1 is a fully specified pathname (does not depend on
  196. ;;the current working directory); otherwise returns #f.
  197. (define (absolute-path? file-name)
  198.   (and (string? file-name)
  199.        (positive? (string-length file-name))
  200.        (memv (string-ref file-name 0) '(#\\ #\/))))
  201.  
  202.  
  203. ;;@body Returns #t if the string @1 contains characters used for
  204. ;;specifying glob patterns, namely @samp{*}, @samp{?}, or @samp{[}.
  205. (define (glob-pattern? str)
  206.   (let loop ((idx (+ -1 (string-length str))))
  207.     (if (negative? idx)
  208.     #f
  209.     (case (string-ref str idx)
  210.       ((#\* #\[ #\?) #t)
  211.       (else (loop (+ -1 idx)))))))
  212.  
  213. ;;@body
  214. ;;Returns a list of the decoded FTP @1; or #f if indecipherable.  FTP
  215. ;;@dfn{Uniform Resource Locator}, @dfn{ange-ftp}, and @dfn{getit}
  216. ;;formats are handled.  The returned list has four elements which are
  217. ;;strings or #f:
  218. ;;
  219. ;;@enumerate 0
  220. ;;@item
  221. ;;username
  222. ;;@item
  223. ;;password
  224. ;;@item
  225. ;;remote-site
  226. ;;@item
  227. ;;remote-directory
  228. ;;@end enumerate
  229. (define (parse-ftp-address url)
  230.   (define length? (lambda (len lst) (and (eqv? len (length lst)) lst)))
  231.   (cond
  232.    ((not url) #f)
  233.    ((length? 1 (scanf-read-list " ftp://%s %s" url))
  234.     => (lambda (host)
  235.      (let ((login #f) (path #f) (dross #f))
  236.        (sscanf (car host) "%[^/]/%[^@]%s" login path dross)
  237.        (and login
  238.         (append (cond
  239.              ((length? 2 (scanf-read-list "%[^@]@%[^@]%s" login))
  240.               => (lambda (userpass@hostport)
  241.                    (append
  242.                 (cond ((length? 2 (scanf-read-list
  243.                            "%[^:]:%[^@/]%s"
  244.                            (car userpass@hostport))))
  245.                       (else (list (car userpass@hostport) #f)))
  246.                 (cdr userpass@hostport))))
  247.              (else (list "anonymous" #f login)))
  248.             (list path))))))
  249.    (else
  250.     (let ((user@site #f) (colon #f) (path #f) (dross #f))
  251.       (case (sscanf url " %[^:]%[:]%[^@] %s" user@site colon path dross)
  252.     ((2 3)
  253.      (let ((user #f) (site #f))
  254.        (cond ((or (eqv? 2 (sscanf user@site "/%[^@/]@%[^@]%s"
  255.                       user site dross))
  256.               (eqv? 2 (sscanf user@site "%[^@/]@%[^@]%s"
  257.                       user site dross)))
  258.           (list user #f site path))
  259.          ((eqv? 1 (sscanf user@site "@%[^@]%s" site dross))
  260.           (list #f #f site path))
  261.          (else (list #f #f user@site path)))))
  262.     (else
  263.      (let ((site (scanf-read-list " %[^@/] %s" url)))
  264.        (and (length? 1 site) (list #f #f (car site) #f)))))))))
  265.  
  266. ;;@body
  267. ;;@3 must be a non-empty string or #f.  @1 must be a non-empty list
  268. ;;of pathnames or Glob patterns (@pxref{Filenames}) matching files to
  269. ;;transfer.
  270. ;;
  271. ;;@0 puts the files specified by @1 into the @5 directory of FTP @4
  272. ;;using name @2 with (optional) @3.
  273. ;;
  274. ;;If @3 is #f and @2 is not @samp{ftp} or @samp{anonymous}, then @2 is
  275. ;;ignored; FTP takes the username and password from the @file{.netrc}
  276. ;;or equivalent file.
  277. (define (ftp-upload paths user password remote-site remote-dir)
  278.   (call-with-tmpnam
  279.    (lambda (script logfile)
  280.      (define local-path (current-directory))
  281.      (define passwd (or password (user-email-address)))
  282.      (dynamic-wind
  283.       (lambda () #f)
  284.       (lambda ()
  285.     (call-with-current-continuation
  286.      (lambda (exit)
  287.        (define (run-ftp-script paths)
  288.          (call-with-output-file script
  289.            (lambda (port)
  290.          (define lcd "")
  291.          (cond ((or (member user '(ftp anonymous "ftp" "anonymous"))
  292.                 password)
  293.             (fprintf port "user %s %s\n" user passwd)))
  294.          (fprintf port "binary\n") ; Turn binary ON for all transfers
  295.          ;;(fprintf port "prompt\n") ; Turn prompt OFF for possible mget
  296.          (if (not (null-directory? remote-dir))
  297.              (fprintf port "cd %s\n" remote-dir))
  298.          (for-each
  299.           (lambda (path-name)
  300.             (let* ((r/i (string-reverse-index path-name #\/))
  301.                (dir (if r/i (substring path-name 0 (+ 1 r/i)) ""))
  302.                (file-name (if r/i
  303.                       (substring path-name (+ 1 r/i)
  304.                              (string-length path-name))
  305.                       path-name)))
  306.               (cond ((and r/i (glob-pattern? dir))
  307.                  (slib:warn
  308.                   "Wildcard not allowed in directory component "
  309.                   path-name)
  310.                  (exit #f))
  311.                 ((and (not (glob-pattern? file-name))
  312.                   (not (file-exists? path-name)))
  313.                  (slib:warn " file doesn't exist:" path-name)
  314.                  (exit #f))
  315.                 ((equal? lcd dir))
  316.                 ((absolute-path? dir)
  317.                  (fprintf port "lcd %s\n" dir))
  318.                 ((eqv? 0 (substring? lcd dir))
  319.                  (fprintf port "lcd %s\n"
  320.                       (substring dir (string-length lcd)
  321.                          (string-length dir))))
  322.                 (else
  323.                  (fprintf port "lcd %s\n" local-path)
  324.                  (if (not (null-directory? dir))
  325.                  (fprintf port "lcd %s\n" dir))))
  326.               (set! lcd dir)
  327.               (cond ((glob-pattern? file-name)
  328.                  (fprintf port "mput %s\n" file-name))
  329.                 (else
  330.                  (fprintf port "put %s\n" file-name)))))
  331.           paths)))
  332.          ;;(display-file script)
  333.          (cond
  334.           ((zero? (system
  335.                (string-append
  336.             "ftp "
  337.             (if (or (member user '(ftp anonymous "ftp" "anonymous"))
  338.                 password)
  339.                 "-inv" "-iv")
  340.             " " remote-site
  341.             " <" script
  342.             " >" logfile)))
  343.            (file-exists? logfile)
  344.            (call-with-input-file logfile
  345.          (lambda (port)
  346.            (do ((line (read-line port) (read-line port)))
  347.                ((or (eof-object? line)
  348.                 (substring-ci? "Unknown host" line)
  349.                 (substring-ci? "Not connected" line)
  350.                 (and (memv (string-ref line 0) '(#\4 #\5))
  351.                  (not (substring-ci? "bytes" line))))
  352.             (cond ((eof-object? line) #t)
  353.                   (else (slib:warn line) #f)))
  354.              ;;(write-line line)
  355.              ))))
  356.           (else (slib:warn 'ftp 'failed) #f)))
  357.        (cond ((or local-path (every? absolute-file? paths))
  358.           (run-ftp-script paths))
  359.          (else (for-each (lambda (path) (run-ftp-script (list path)))
  360.                  paths))))))
  361.       (lambda ()
  362.     (if (file-exists? script) (delete-file script))
  363.     (if (file-exists? logfile) (delete-file logfile)))))
  364.    2))
  365.  
  366. ;;@body
  367. ;;Returns a URL-string for @1 on the local host.
  368. (define (path->url path)
  369.   (if (absolute-path? path)
  370.       (sprintf #f "file:%s" path)
  371.       (sprintf #f "file:%s/%s" (current-directory) path)))
  372.  
  373. ;;@body
  374. ;;If a @samp{netscape} browser is running, @0 causes the browser to
  375. ;;display the page specified by string @1 and returns #t.
  376. ;;
  377. ;;If the browser is not running, @0 runs @samp{netscape} with the
  378. ;;argument @1.  If the browser starts, @0 returns #t when the browser
  379. ;;exits; otherwise it returns #f.
  380. (define (browse-url-netscape url)
  381.   (or (eqv? 0 (system (sprintf #f "netscape-remote -remote 'openURL(%s)'" url)))
  382.       (eqv? 0 (system (sprintf #f "netscape -remote 'openURL(%s)'" url)))
  383.       (eqv? 0 (system (sprintf #f "netscape '%s'" url)))))
  384.